Option Explicit
Sub Run()

    Dim workBooksArr(1 To 100000) As String '文件列表数组


    
    Dim gourpColumnIndex '分组列
    gourpColumnIndex = InputBox("第几列为分组列", "输入分组列", "A")
    Dim rowIndex, maxCloumn
    rowIndex = 2
    Dim tmpValue
    maxCloumn = InputBox("最大列名", "最大列", "W")
    
    Dim fileSavePath '文件存储目录
    fileSavePath = InputBox("第几列为分组列", "文件存储目录", "D:\project\")
    Dim dataWorkBookName
    dataWorkBookName = ThisWorkbook.Name
    tmpValue = "init"
    Dim lastKey, startIndex
    lastKey = ""

    Columns(gourpColumnIndex & ":" & gourpColumnIndex).Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add key:=Range(gourpColumnIndex & "1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("A2:" & maxCloumn & ActiveSheet.Cells(1, 1).End(xlDown).Row)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    startIndex = 2
    While tmpValue <> ""
      Windows(dataWorkBookName).Activate
      tmpValue = Range(gourpColumnIndex & rowIndex).Value
      If tmpValue <> "" Then
         If contain(workBooksArr, tmpValue) = False Then
           '文件不存在，创建文件/复制表头
            Workbooks.Add
            Application.WindowState = xlNormal
    
            ActiveWorkbook.SaveAs Filename:=fileSavePath & tmpValue & ".xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
            Call setKey(workBooksArr, tmpValue)
            Windows(dataWorkBookName).Activate
            Range("A1:" + maxCloumn + "1").Select
            Selection.Copy
            Windows(tmpValue + ".xlsx").Activate
            Range("A1").Select
            ActiveSheet.Paste
            Range("A2").Select

         End If
         If lastKey = "" Then
           
         ElseIf lastKey <> tmpValue Then
            '复制数据
            Windows(dataWorkBookName).Activate
            Range("A" & startIndex & ":" & maxCloumn & (rowIndex - 1)).Select
             Selection.Copy
            Windows(lastKey + ".xlsx").Activate
            ActiveSheet.Paste
            Range("A" & (ActiveSheet.Cells(1, 1).End(xlDown).Row + 1)).Select
            startIndex = rowIndex
         End If
         lastKey = tmpValue
     Else
       '处理最后一个组
        Windows(dataWorkBookName).Activate
        Range("A" & startIndex & ":" & maxCloumn & (rowIndex - 1)).Select
        Selection.Copy
        Windows(lastKey + ".xlsx").Activate
        ActiveSheet.Paste
     End If
     rowIndex = rowIndex + 1
    Wend
    Windows(dataWorkBookName).Activate
    Dim activeNum
    activeNum = ActiveSheet.Cells(1, 1).End(xlDown).Row
    Call saveAllFile(workBooksArr, activeNum)
End Sub
Sub setKey(arr, key)
  Dim j
  For j = LBound(arr) To UBound(arr)
    If arr(j) = "" Then
        arr(j) = key
        Exit Sub
    End If
  Next
End Sub
Function contain(arr, key)
  Dim j
  For j = LBound(arr) To UBound(arr)
    If arr(j) = key Then
        contain = True
        Exit Function
    ElseIf arr(j) = "" Then
      contain = False
      Exit Function
    End If
  Next
  contain = False
End Function
Sub saveAllFile(arr, activeNum)
  Dim j, allStr, n, sum
  sum = 0
  For j = LBound(arr) To UBound(arr)
    If arr(j) <> "" Then
        Windows(arr(j) & ".xlsx").Activate
        n = ActiveSheet.Cells(1, 1).End(xlDown).Row - 1
        allStr = allStr & n & "(" & arr(j) & ")+"
        sum = sum + n
        If j Mod 12 = 0 And j > 0 Then
         allStr = allStr & Chr(10)
        End If
        ActiveWorkbook.Save
    ElseIf arr(j) = "" Then
      Exit For
    End If
  Next
  allStr = Mid(allStr, 1, Len(allStr) - 1) & Chr(10)
  If sum <> activeNum - 1 Then
   allStr = allStr & Chr(13) & sum & "!=" & activeNum
   MsgBox allStr, vbExclamation, "拆分后的数量与拆分前不一致"
  Else
   allStr = allStr & Chr(13) & sum & "=" & (activeNum - 1)
   MsgBox allStr, vbInformation, "拆分成功"
  End If
End Sub